home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swaga_c.zip / ANSI.SWG / 0035_Use LVI Color on BBS.pas < prev    next >
Pascal/Delphi Source File  |  1995-03-03  |  11KB  |  507 lines
  1. {
  2. *****************************************************************************
  3.  
  4.                   COLOR.PAS
  5.  
  6.  By Tobin Fricke
  7.  
  8.  This should solve everyone's problems with Ascii, ANSI, WWIV, Avatar, LVI,
  9.  Pipe, Direct, and RIP.
  10.  
  11.  
  12. *****************************************************************************
  13. }
  14. {$IFDEF DEBUG}
  15. {$D+,L+}
  16. {$ENDIF}
  17.  
  18. Unit Color;
  19.  
  20. {$S-}
  21.  
  22. (* BBS Color Unit by Tobin Fricke                                          *)
  23. (* TobinTech Software Research and Development                             *)
  24. (* Copyright (c) 1994 Tobin Fricke, All Rights Reserved                    *)
  25.  
  26. (* This is a unit to allow the use of color on bbs systems.  It will send  *)
  27. (* the color codes to the screen using BIOS.  These can easily be trapped  *)
  28. (* and sent to the modem by most BBS systems.                              *)
  29.  
  30.  
  31. (* -=- If you use this in any of your programs, you must give credit to the
  32.        author of this toolkit, Tobin Fricke.  You must register this and 
  33.        receive permission to use it in any commercial product or shareware
  34.        product.  It may be used without consent from the author (as long as
  35.        credit is given) in any "freeware" or "public domain" programs. This
  36.        may not be bought or sold, and contains no warrantee.  Use it at your
  37.        own risk.  Please send the author a copy of anything you create using
  38.        this toolkit.  Thanks.  For information on registration, contact the
  39.        author. *)
  40.  
  41. (* -=- Reaching The Author                                                 
  42.      
  43.        Internet:        dr261@cleveland.freenet.edu
  44.  
  45.  
  46.        Postal:          25271 Arion Way, Mission Viejo, Ca, 92691-3702
  47.  
  48.     
  49.        Phone:           (714) 586-4906
  50.  
  51.        
  52.        BBS:             (714) 586-6142 The Digital Forest Information system
  53.  
  54.  
  55.        DFIN:            13:714/100
  56.  
  57.     *)
  58.     
  59.     
  60.  
  61. Interface
  62.  
  63. uses DOS;
  64.  
  65. Type ProcType=Procedure(S:String);
  66.  
  67. Const NoColor=0;              { Ignores Color commands, no color         }
  68.       ASCIIColor=0;           { Same as NoColor                          }
  69.       ANSIColor=1;            { Uses ANSI Escape Codes                   }
  70.       WWIVColor=2;            { Uses WWIV Heart  Codes                   }
  71.       AVATARColor=3;          { Uses AVATAR codes                        }
  72.       LVIColor=4;             { Uses LVI (Last Video Interface)  codes   }
  73.       DirectColor=7;
  74.       PipeSystemColor=5;      { The Renegade Pipe System for Color       }
  75.       RipColor=6;
  76.  
  77.       WWIVEscape:Char=#3;     { These are escape codes for the different }
  78.       ANSIEscape:Char=#27;    { modes.                                   }
  79.       AVATEscape:Char=#22;
  80.  
  81.       Black=0;                { These are color constants.               }
  82.       Blue=1;
  83.       Green=2;
  84.       Cyan=3;
  85.       Red=4;
  86.       Magenta=5;
  87.       Brown=6;
  88.       Gray=7;
  89.       Bright=8;
  90.  
  91.       EmuNum=6;
  92.       EmuMenu:Array[0..EmuNum] of String=
  93.        ('ASCII ',
  94.     'ANSI  ',
  95.     'WWIV  ',
  96.     'AVATAR',
  97.     'LVI   ',
  98.     'PIPE System',
  99.     'RIPScrip');
  100.       EmuComment:Array[0..EmuNum] of String=
  101.       ('No Color or Screen Control',
  102.        'ANSI Color and Screen Control',
  103.        'WWIV BBS Software "Heart Codes"',
  104.        'This isn''t used much anymore',
  105.        'The Last Video Interface, Faster than ANSI',
  106.        'Renegade Style Color Codes',
  107.        'Remote Imaging Protocol Script');
  108.  
  109. var WriteMode:Byte;           { Prior to use, you must set WriteMode equal }
  110.     Output:ProcType;          { to NoColor, ANSIcolor, AVATARColor, or LVI-}
  111.                   { color }
  112.  
  113. Var T:Text;                   {Assigned to StdOutput }
  114.  
  115.  
  116. Procedure Default;                  { Change colors to default (7 on 0) }
  117. Procedure BackgroundColor(I:Byte);  { Set Background color to I         }
  118. Procedure ForgroundColor(I:Byte);   { Set Foreground Color to I         }
  119. Procedure GotoXY(X,Y:Byte);         { Go to specific location on screen }
  120. Procedure CLRSCR;                   { Clear the screen                  }
  121. function readkey:char;              { Not Implemented Yet               }
  122. Procedure D;                        { Same as Default;                  }
  123. Procedure WWIVParse(S:String);      { See the end of this file...       }
  124. Procedure GetEmu;                   { See the end of this file...       }
  125. Procedure FColor(B:Byte);           { Same as ForegroundColor           }
  126. Procedure BColor(B:Byte);           { Same as BackgroundColor           }
  127.  
  128. Implementation
  129.  
  130. Uses CRT;
  131.  
  132.  
  133.  
  134.  
  135. Procedure DefOutput(S:StrinG);
  136. Begin
  137.  Write(T,S);
  138. End;
  139.  
  140. {function readkey:char;
  141. var B:Byte;
  142. begin
  143.  ASM;
  144.   Mov AH, 01h
  145.   Int 21
  146.   Mov [B], AL
  147.  End;
  148.  readkey:=chr(B);
  149. end; }
  150. function readkey:char;
  151. var it:string;
  152.     Regs:Registers;
  153. begin
  154. Regs.AH:=$01;
  155. MSDOS(Regs);
  156. STr(Regs.AL,it);
  157. readkey:=it[1];
  158. end;
  159.  
  160. Procedure PIPEBackground(B:Byte);
  161. Var S:String;
  162. Begin
  163.  Case B Of
  164.    0: S:='|16';
  165.    1: S:='|17';
  166.    2: S:='|18';
  167.    3: S:='|19';
  168.    4: S:='|20';
  169.    5: S:='|21';
  170.    6: S:='|22';
  171.    7: S:='|23';
  172.   End;
  173.  Write(S);
  174. End;
  175.  
  176. Procedure PIPEForground(B:Byte);
  177. Var S:String;
  178. Begin
  179.  Case B Of
  180.    0: S:='|00';
  181.    1: S:='|01';
  182.    2: S:='|02';
  183.    3: S:='|03';
  184.    4: S:='|04';
  185.    5: S:='|05';
  186.    6: S:='|06';
  187.    7: S:='|07';
  188.    8: S:='|08';
  189.    9: S:='|09';
  190.   10: S:='|10';
  191.   11: S:='|11';
  192.   12: S:='|12';
  193.   13: S:='|13';
  194.   14: S:='|14';
  195.   15: S:='|15';
  196.   End;
  197.  Write(S);
  198. End;
  199.  
  200.  
  201. Procedure AVATARGotoXy(X,Y:Byte);
  202. begin
  203.  Write(#22+#8+Char(X)+Char(Y));
  204. end;
  205.  
  206. Procedure AvatarForground(A:Byte);
  207. begin
  208.  Write(#22+#1+Char(A and $7F));
  209. end;
  210.  
  211. Procedure AvatarClrScr;
  212. begin
  213.  Write(#12);
  214. end;
  215.  
  216. Procedure WWIVForground(I:Byte);
  217. var C:Byte;
  218.     D:Char;
  219. begin
  220.  Repeat
  221.   If I>8 then I:=I-8;
  222.  Until I<9;
  223.  C:=I;
  224.  Case I of
  225.     0:C:=0;
  226.     1:C:=7;
  227.     2:C:=5;
  228.     3:C:=1;
  229.     4:C:=6;
  230.     5:C:=3;
  231.     6:C:=2;
  232.     7:C:=4;
  233.     8:C:=4;
  234.   end;
  235.   Output(WWIVEscape+Char(48+C));
  236. end;
  237.  
  238. Procedure WWIVBackground(I:Byte);
  239. begin
  240.  If I=1 then Output(WWIVEscape+'4');
  241. end;
  242.  
  243. procedure ANSIDefault;
  244. begin
  245.  Output(ANSIEscape+'[0m');
  246. end;
  247.  
  248. Procedure ANSIForground(I:Byte);
  249. var z:string;
  250. begin
  251. {ANSIDefault;}
  252. case I of
  253.      0:z:='0;30';
  254.      1:z:='0;34';
  255.      2:z:='0;32';
  256.      3:z:='0;36';
  257.      4:z:='0;31';
  258.      5:z:='0;35';
  259.      6:z:='0;33';
  260.      7:z:='0;37';
  261.      8:z:='1;30';
  262.      9:z:='1;34';
  263.      10:z:='1;32';
  264.      11:z:='1;36';
  265.      12:z:='1;31';
  266.      13:z:='1;35';
  267.      14:z:='1;33';
  268.      15:z:='1;37';
  269.      end;
  270. Output(ANSIescape+'['+z+'m');
  271. end;
  272.  
  273. Procedure ANSIBackground(I:Byte);
  274. var z:string;
  275.     ansistr:string;
  276. begin
  277. { ANSIDefault;}
  278.  case I of
  279.       0:z:='40';
  280.       1:z:='44';
  281.       2:z:='42';
  282.       3:z:='46';
  283.       4:z:='41';
  284.       5:z:='45';
  285.       6:z:='43';
  286.       7:z:='47';
  287.       end;
  288. ansistr:=ANSIEscape+'['+z+'m';
  289. Output(ansistr);
  290. end;
  291.  
  292. Procedure GotoXY(X,Y:Byte);
  293. var SX,SY:string;
  294. begin
  295. Str(X,SX);
  296. Str(Y,SY);
  297. Output(ANSIEscape+'['+SY+';'+SX+'H');
  298. end;
  299.  
  300. Var F,B:Byte;
  301.  
  302. Procedure LVIForground(I:Byte);
  303. Begin
  304.  F:=I;
  305.  Output(#29+Char(F+(B*16)));
  306. end;
  307.  
  308. Procedure LVIBackground(I:Byte);
  309. Begin
  310.  B:=I;
  311.  Output(#29+Char(F+(B*16)));
  312. end;
  313.  
  314. Procedure Zero(Var X:Byte);
  315. Begin
  316.  X:=0;
  317. end;
  318.  
  319. Procedure FColor(B:Byte);
  320. Begin
  321.  ForgroundColor(B);
  322. end;
  323.  
  324. Procedure BColor(B:Byte);
  325. Begin
  326.  BackgroundColor(B);
  327. End;
  328.  
  329. Procedure WWIVParse(S:String);
  330. var I:Byte;
  331. begin
  332.  Zero(I);
  333.  Repeat
  334.   Inc(I);
  335.   Case S[I] of
  336.     #3:Begin            { #3 =  }
  337.     Inc(I);
  338.     Case S[I] of
  339.        '0':Begin BColor(0); FColor(7+0);  End;
  340.        '1':Begin BColor(0); FColor(3+8); End;
  341.        '2':Begin BColor(0); FColor(6+8); End;
  342.        '3':Begin BColor(0); FColor(5+0); End;
  343.        '4':Begin BColor(1); FColor(1+0); End;
  344.        '5':Begin BColor(0); FColor(2+0); End;
  345.        '6':Begin BColor(0); FColor(4+8); End;
  346.        '7':Begin BColor(0); FColor(1+8); End;
  347.        '8':Begin BColor(0); FColor(2+8); End;
  348.        '9':Begin BColor(0); FColor(3+8); End;
  349.       End;
  350.     End;
  351.     Else Output(S[I]);
  352.   End;
  353.  Until I>=Length(S);
  354. End;
  355.  
  356. Procedure BackgroundColor(I:Byte);
  357. begin
  358.  Case WriteMode of
  359.    ANSIColor:ANSIBackground(I);
  360.    RIPColor:ANSIBackground(I);
  361.    WWIVColor:WWIVBackground(I);
  362.    LVIColor:LVIBackground(I);
  363.    DirectColor:CRT.TextBackground(I);
  364.    PipeSystemColor:PipeBackground(I);
  365.    end;
  366. end;
  367.  
  368. Procedure ForgroundColor(I:Byte);
  369. begin
  370.  Case WriteMode of
  371.    ANSIColor:ANSIForground(I);
  372.    RIPColor:ANSIForground(I);
  373.    WWIVColor:WWIVForground(I);
  374.    AVATARColor:AvatarForground(I);
  375.    LVIColor:LVIForground(I);
  376.    DirectColor:CRT.TextColor(I);
  377.    PipeSystemColor:PipeForground(I);
  378.    end;
  379. end;
  380.  
  381. Procedure ANSIClrScr;
  382. begin
  383. Output(ANSIEscape+'[2J');
  384. end;
  385.  
  386. Procedure WWIVClrScr;
  387. var I:Byte;
  388. begin
  389.   For I:=1 to 25 do Writeln(T,'');
  390. end;
  391.  
  392. Procedure ClrScr;
  393. begin
  394.  Case WriteMode of
  395.     ANSIColor:ANSIClrScr;
  396.     RIPColor:ANSIClrScr;
  397.     WWIVColor:WWIVClrScr;
  398.     AVATARColor:AvatarClrScr;
  399.     LVIColor:ANSIClrScr;
  400.     DirectColor:CRT.ClrScr;
  401.     end;
  402. end;
  403.  
  404. Procedure Default;
  405. Begin
  406.  Case Writemode of
  407.   ANSIColor: ANSIDefault;
  408.   RipColor:  ANSIDefault;
  409.   end;
  410. end;
  411.  
  412. Procedure D;
  413. begin
  414.  Default;
  415. end;
  416.  
  417. Procedure GetEMu;
  418. Var I,E:Integer;
  419.     S:String;
  420.     T:Integer;
  421. Begin
  422. Repeat
  423.  Writeln(' Please choose a terminal type: ');
  424.  Writeln;
  425.  For I:=0 to Color.EmuNum do
  426.      Writeln(' ',I,') ',Color.EmuMenu[I],#9,Color.EmuComment[I]);
  427.  Writeln;
  428.  Write(' TERM>');
  429.  Readln(S);
  430.  Val(S,T,E);
  431.  If E<>0 then begin
  432.     Writeln(' I can''t understand: ',S);
  433.     Write('                    ');
  434.     For I:=1 to E do Write(' ');
  435.     Writeln('^');
  436.     End;
  437.  If ((T>Color.EmuNum) OR (T<0)) AND (E=0) then begin
  438.     Writeln(' You must enter a number from 0 to ',EmuNum);
  439.     E:=1;
  440.     end;
  441. Until E=0;
  442. Writeln;
  443. Writeln(' ',EmuMenu[T],' Emulation Selected ');
  444. WriteMode:=T;
  445. end;
  446.  
  447.  
  448. begin
  449.  Output:=DefOutput;
  450.  Assign(System.Output,'');
  451.  Assign(System.Input,'');
  452.  Assign(T,'');
  453.  Rewrite(T);
  454.  Rewrite(System.Output);
  455.  Reset(Input);
  456.  DirectVideo:=False;
  457.  WriteMode:=ANSIColor;
  458.  F:=7;
  459.  B:=0;
  460. end.
  461.  
  462. (*  Information...
  463.  
  464.  
  465.  
  466.       Set WriteMode to one of the following before calling any color commands.
  467.  
  468.  
  469.       NoColor=0;              { Ignores Color commands, no color         }
  470.       ASCIIColor=0;           { Same as NoColor                          }
  471.       ANSIColor=1;            { Uses ANSI Escape Codes                   }
  472.       WWIVColor=2;            { Uses WWIV Heart  Codes                   }
  473.       AVATARColor=3;          { Uses AVATAR codes                        }
  474.       LVIColor=4;             { Uses LVI (Last Video Interface)  codes   }
  475.       DirectColor=7;          { Not implemented yet  }
  476.       PipeSystemColor=5;      { The Renegade Pipe System for Color       }
  477.       RipColor=6;
  478.  
  479.  
  480.       For TTY emulation, see TTY.PAS
  481.       For LVI emulation, see LVI.PAS
  482.  
  483.  
  484.       Output(S:String) Is called to output the ANSI/WWIV/AVATAR/LVI/PIPE/RIP
  485.       codes.  It defaults to StdOutput, and It may be redefined like so:
  486.  
  487.  
  488.       Procedure COMOutput(S:String);
  489.       begin
  490.        { send S to COMPort }
  491.  
  492.       end;
  493.  
  494.  
  495.       begin
  496.        Color.Output:=ComOutput;
  497.       end.
  498.  
  499.  
  500.       WWIVParse(S:String) will take a string containing WWIV (ASCII 3) color
  501.       codes, parse it, and output it (through procedure output) with the 
  502.       correct coloring.
  503.  
  504.  
  505.       GetEmu will display a menu and ask the user for an emulation.
  506. *)
  507.